perm filename NEWDIM.SAI[9,ALS] blob
sn#201860 filedate 1971-05-13 generic text, type T, neo UTF8
00100 BEGIN "TWODIM"
00200
00300 REQUIRE "PROLOG.HDR[1,PDQ]" SOURCE_FILE;
00400 REQUIRE "COMSUB.HDR[1,PDQ]" SOURCE_FILE;
00500 REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE_FILE;
01100 FORTRAN REAL PROCEDURE ALOG10(REAL X);
01110 FORTRAN REAL PROCEDURE COS(REAL X);
01120 FORTRAN REAL PROCEDURE SIN(REAL X);
01140 FORTRAN REAL PROCEDURE SQRT(REAL X);
01200 PICTURE PIC,RPIC,IPIC,PPIC[0:PICMAX];
01300 DEFINE DPYSIZ="1000";
01400 INTEGER_ARRAY DPYBUF[1:DPYSIZ];
03000 REAL_ARRAY A,B,C[0:512];
03050 INTEGER_ARRAY AIBLK,FTBLK[1:300];
03060 REAL_ARRAY RLSCL,ILSCL,RCSCL,ICSCL[0:257];
03070 REAL_ARRAY LSINE,CSINE[0:256];
03100 REAL SC,SCALE,PI;
03200 INTEGER AIFORM,FFTOUT;
03250 STRING ANS;
03300 STRING PICID,TPICID;
03350 INTEGER RBYTE,IBYTE,HOLD;
03400 INTEGER NUM,OUTCHN;
03405 INTEGER LFILL1,LFILL2,CFILL1,CFILL2;
03410 INTEGER CLINE,NLINE,I,BPS;
03415 INTEGER PPL,LINES,LN,LM,CN,CM;
03420 LABEL START,GETLIN,SKIP1,SKIP2;
03430 LABEL NEWPIC;
03500
03550
03600
03700 INTERNAL INTEGER BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,LSIDE,RSIDE,TVWORD,SIZE;
03800
03900 PROCEDURE QTOHE(PICTURE PIC);
04000 ⊃ Conversion from Quam format picture header array to hand-eye
04100 library style parameters;
04200 BEGIN IWID←PIC[SIZEX];FLINE←PIC[POSY];LSIDE←PIC[POSX];
04300 RSIDE←LSIDE+IWID-1;LLINE←FLINE+PIC[SIZEY]-1;
04400 LINLEN←PIC[SIZEL];BITS←PIC[BIT];SIZE←LINLEN*PIC[SIZEY];
04500 BCLIP←PIC[OFFSET];TCLIP←PIC[GAIN];
04600 END "QTOHE";
04700
04800
04900 PROCEDURE HETOQ(PICTURE PIC);
05000 ⊃ Conversion from hand-eye library parameters to Quam format picture
05100 header array;
05200 BEGIN PIC[SCALEX]←PIC[SCALEY]←1;
05300 PIC[POSX]←LSIDE;PIC[POSY]←FLINE;
05400 PIC[SIZEX]←RSIDE-LSIDE+1;PIC[SIZEY]←LLINE-FLINE+1;
05500 PIC[SIZEL]←LINLEN;
05600 PIC[PTR]←XPOINT(BITS,"((TVWORD+1)LAND '777777)",-1);
05700 PIC[BIT]←BITS;
05800 IF ABS(TCLIP)≤30 THEN BEGIN PIC[GAIN]←0;PIC[OFFSET]←0;END
05900 ELSE BEGIN PIC[GAIN]←TCLIP;PIC[OFFSET]←BCLIP;END;
06000 END "HETOQ";
06100
00100 PROCEDURE FFT(REAL_ARRAY A,B;INTEGER N,M,KS);
00200 BEGIN
00300 COMMENT COMPUTES THE FFT FOR ONE VARIABLE OF DIMENSION 2↑M;
00400 INTEGER K0,K1,K2,K3,SPAN,J,JJ,K,KB,KN,MM,MK;
00500 REAL RAD,C1,C2,C3,S1,S2,S3,CK,SK,SQ;
00600 REAL A0,A1,A2,A3,B0,B1,B2,B3;
00700 INTEGER_ARRAY C[0:M];
00750 LABEL L,L2,L3,L4,L5,L6;
00800 SQ←0.707106781187;
00900 SK←0.382683432366;
01000 CK←0.92387953251;
01100 C[M]←KS; MM←(M%2)*2; KN←0;
01200 FOR K←M-1 STEP -1 UNTIL 0 DO C[K]←C[K+1]/2;
01300 RAD←6.28318530718/(C[0]*KS); MK←M-5;
01400 L: KB←KN; KN←KN+KS;
01500 IF MM≠N THEN
01600 BEGIN
01700 K2←KN; K0←C[MM]+KB;
01800 L2: K2←K2-1; K0←K0-1;
01900 A0←A[K2]; B0←B[K2];
02000 A[K2]←A[K0]-A0; A[K0]←A[K0]+A0;
02100 B[K2]←B[K0]-B0; B[K0]←B[K0]+B0;
02200 IF K0>KB THEN GO TO L2;
02300 END;
02400 C1←1.0; S1←0;
02500 JJ←0; K←MM-2; J←3;
02600 IF K≥0 THEN GO TO L4 ELSE GO TO L6;
02700 L3: IF C[J]≤JJ THEN
02800 BEGIN
02900 JJ←JJ-C[J]; J←J-1;
03000 IF C[J]≤JJ THEN
03100 BEGIN
03200 JJ←JJ-C[J]; J←J-1; K←K+2;
03300 GO TO L3;
03400 END
03500 END;
03600 JJ←C[J]+JJ; J←3;
03700 L4: SPAN←C[K];
03800 IF JJ≠0 THEN
03900 BEGIN
04000 C2←JJ*SPAN*RAD; C1←COS(C2); S1←SIN(C2);
04100 L5: C2←C1↑2-S1↑2; S2←2.0*C1*S1;
04200 C3←C2*C1-S2*S1; S3←C2*S1+S2*C1;
04300 END;
04400 FOR K0←KB+SPAN-1 STEP -1 UNTIL KB DO
04500 BEGIN
04600 K1←K0+SPAN; K2←K1+SPAN; K3←K2+SPAN;
04700 A0←A[K0]; B0←B[K0];
04800 IF S1=0 THEN
04900 BEGIN
05000 A1←A[K1]; B1←B[K1];
05100 A2←A[K2]; B2←B[K2];
05200 A3←A[K3]; B3←B[K3];
05300 END
05400 ELSE
05500 BEGIN
05600 A1←A[K1]*C1-B[K1]*S1;
05700 B1←A[K1]*S1+B[K1]*C1;
05800 A2←A[K2]*C2-B[K2]*S2;
05900 B2←A[K2]*S2+B[K2]*C2;
06000 A3←A[K3]*C3-B[K3]*S3;
06100 B3←A[K3]*S3+B[K3]*C3;
06200 END;
06300 A[K0]←A0+A2+A1+A3; B[K0]←B0+B2+B1+B3;
06400 A[K1]←A0+A2-A1-A3; B[K1]←B0+B2-B1-B3;
06500 A[K2]←A0-A2-B1+B3; B[K2]←B0-B2+A1-A3;
06600 A[K3]←A0-A2+B1-B3; B[K3]←B0-B2-A1+A3;
06700 END;
06800 IF K>0 THEN BEGIN K←K-2; GO TO L4; END;
06900 KB←K3+SPAN;
07000 IF KB<KN THEN
07100 BEGIN
07200 IF J=0 THEN BEGIN K←2; J←MK; GO TO L3; END;
07300 J←J-1; C2←C1;
07400 IF J=1 THEN
07500 BEGIN C1←C1*CK+S1*SK; S1←S1*CK-C2*SK; END
07600 ELSE BEGIN C1←(C1-S1)*SQ; S1←(C2+S1)*SQ; END;
07700 GO TO L5;
07800 END;
07900 L6: IF KN<N THEN GO TO L;
08000 END "FFT";
08100
08200
08300
08400
08500 PROCEDURE REVFFT(REAL_ARRAY A,B;INTEGER N,M,KS);
08600 BEGIN
08700 COMMENT COMPUTES THE FFT FOR ONE VARIABLE OF DIMENSION 2↑M IN A
08800 MULTIVARIATE TRANSFORM.
08900 IF N=2↑M AND K=1 THEN A SINGLE-VARIATE TRANSFORM IS COMPUTED;
09000 INTEGER K0,K1,K2,K3,K4,SPAN,NN,J,JJ,K,KB,NT,KN,MK;
09100 REAL RAD,C1,C2,C3,S1,S2,S3,CK,SK,SQ;
09200 REAL A0,A1,A2,A3,B0,B1,B2,B3,RE,IM;
09300 INTEGER_ARRAY C[0:M];
09350 LABEL L,L2,L3,L4,L5,L6;
09400 SQ←0.707106781187;
09500 SK←0.382683432366;
09600 CK←0.92387953251;
09700 C[0]←KS; KN←0; K4←4*KS; MK←M-4;
09800 FOR K←1 STEP 1 UNTIL M DO C[K]←KS←KS+KS;
09900 RAD←3.1415926536/(C[0]*KS);
10000 L: KB←KN+K4; KN←KN+KS;
10100 IF M=1 THEN GO TO L5;
10200 K←JJ←0; J←MK; NT←3;
10300 C1←1.0; S1←0;
10400 L2: SPAN←C[K];
10500 IF JJ≠0 THEN
10600 BEGIN
10700 C2←JJ*SPAN*RAD; C1←COS(C2); S1←SIN(C2);
10800 L3: C2←C1↑2-S1↑2; S2←2*C1*S1;
10900 C3←C2*C1-S2*S1; S3←C2*S1+S2*C1;
11000 END
11100 ELSE S1←0;
11200 K3←KB-SPAN;
11300 L4: K2←K3-SPAN; K1←K2-SPAN; K0←K1-SPAN;
11400 A0←A[K0]; B0←B[K0];
11700 A1←A[K1]; B1←B[K1];
11800 A2←A[K2]; B2←B[K2];
11900 A3←A[K3]; B3←B[K3];
12000 A[K0]←A0+A1+A2+A3; B[K0]←B0+B1+B2+B3;
12050 IF S1=0 THEN
12075 BEGIN
12100 A[K1]←A0-A1-B2+B3; B[K1]←B0-B1+A2-A3;
12200 A[K2]←A0+A1-A2-A3; B[K2]←B0+B1-B2-B3;
12300 A[K3]←A0-A1+B2-B3; B[K3]←B0-B1-A2+A3;
12400 END
12500 ELSE
12600 BEGIN
12700 RE←A0-A1-B2+B3; IM←B0-B1+A2-A3;
12800 A[K1]←RE*C1-IM*S1; B[K1]←RE*S1+IM*C1;
12900 RE←A0+A1-A2-A3; IM←B0+B1-B2-B3;
13000 A[K2]←RE*C2-IM*S2; B[K2]←RE*S2+IM*C2;
13100 RE←A0-A1+B2-B3; IM←B0-B1-A2+A3;
13200 A[K3]←RE*C3-IM*S3; B[K3]←RE*S3+IM*C3;
13300 END;
13400 K3←K3+1; IF K3<KB THEN GO TO L4;
13500 NT←NT-1;
13600 IF NT≥0 THEN
13700 BEGIN
13800 C2←C1;
13900 IF NT=1 THEN
14000 BEGIN C1←C1*CK+S1*SK; S1←S1*CK-C2*SK; END
14100 ELSE BEGIN C1←(C1-S1)*SQ; S1←(C2+S1)*SQ; END;
14200 KB←KB+K4; IF KB≤KN THEN GO TO L3 ELSE GO TO L5;
14300 END;
14400 IF NT=-1 THEN BEGIN K←2; GO TO L2; END;
14500 IF C[J]≤JJ THEN
14600 BEGIN
14700 JJ←JJ-C[J]; J←J-1;
14800 IF C[J]≤JJ THEN
14900 BEGIN JJ←JJ-C[J]; J←J-1; K←K+2; END
15000 ELSE BEGIN JJ←C[J]+JJ; J←MK;END;
15100 END
15200 ELSE BEGIN JJ←C[J]+JJ; J←MK; END;
15300 IF J<MK THEN GO TO L2; K←0; NT←3;
15400 KB←KB+K4; IF KB≤KN THEN GO TO L2;
15500 L5: K←(M%2)*2;
15600 IF K≠M THEN
15700 BEGIN
15800 K2←KN; K0←J←KN-C[K];
15900 L6: K2←K2-1; K0←K0-1;
16000 A0←A[K2]; B0←B[K2];
16100 A[K2]←A[K0]-A0; A[K0]←A[K0]+A0;
16200 B[K2]←B[K0]-B0; B[K0]←B[K0]+B0;
16300 IF K2>J THEN GO TO L6;
16400 END;
16500 IF KN<N THEN GO TO L;
16600 END "REVFFT";
16650
17000 PROCEDURE REORDER(REAL_ARRAY A,B;INTEGER N,M,KS,REEL);
17100 BEGIN
17200 COMMENT PERMUTES DATA FROM NORMAL TO REVERSE BINARY ORDER AND BACK;
17300 INTEGER I,J,JJ,K,KK,KB,K2,KU,LIM,P;
17400 REAL T;
17500 INTEGER_ARRAY C,LST[0:M];
17550 LABEL L,L2,L3,L4;
17600 C[M]←KS;
17700 FOR K←M STEP -1 UNTIL 1 DO C[K-1]←C[K]%2;
17800 P←J←M-1; I←KB←0;
17900 IF REEL THEN
18000 BEGIN
18100 KU←N-2;
18200 FOR K←0 STEP 2 UNTIL KU DO
18300 BEGIN T←A[K+1]; A[K+1]←B[K]; B[K]←T; END;
18400 END
18500 ELSE M←M-1;
18700 LIM←(M+2)%2; IF P≤0 THEN GO TO L4;
18800 L: KU←K2←C[J]+KB; JJ←C[M-J]; KK←KB+JJ;
18900 L2: K←KK+JJ;
19000 L3: T←A[KK]; A[KK]←A[K2]; A[K2]←T;
19100 T←B[KK]; B[KK]←B[K2]; B[K2]←T;
19200 KK←KK+1; K2←K2+1;
19300 IF KK<K THEN GO TO L3;
19400 KK←KK+JJ; K2←K2+JJ;
19500 IF KK<KU THEN GO TO L2;
19600 IF J>LIM THEN
19700 BEGIN
19800 J←J-1; I←I+1;
19900 LST[I]←J; GO TO L;
20000 END;
20100 KB←K2;
20200 IF I>0 THEN
20300 BEGIN J←LST[I]; I←I-1; GO TO L; END;
20400 IF KB<N THEN BEGIN J←P; GO TO L; END;
20500 L4: ;
20600 END "REORDER";
20700
20800
21000 PROCEDURE RTRAN(REAL_ARRAY A,B;INTEGER N,EVALUATE);
21100 BEGIN
21200 COMMENT IF EVALUATE IS FALSE THIS PROCEDURE UNSCRAMBLES THE SINGLE VARIATE
21300 COMPLEX TRANSFORM ;
21400 INTEGER K,NK,NH;
21500 REAL AA,AB,BA,BB,RE,IM,CK,SK,DC,DS,R;
21600 NH←N%2; R←3.1415926536/N;
21700 DS←SIN(R); R←-(2*SIN(0.5*R))↑2;
21800 DC←-0.5*R; CK←1.0; SK←0;
21900 IF EVALUATE THEN
22000 BEGIN
22100 CK←-1.0; DC←-DC;
22200 END
22300 ELSE
22400 BEGIN
22500 A[N]←A[0]; B[N]←B[0];
22600 END;
22700 FOR K←0 STEP 1 UNTIL NH DO
22800 BEGIN
22900 NK←N-K;
23000 AA←A[K]+A[NK]; AB←A[K]-A[NK];
23100 BA←B[K]+B[NK]; BB←B[K]-B[NK];
23200 RE←CK*BA+SK*AB; IM←SK*BA-CK*AB;
23300 B[NK]←IM-BB; B[K]←IM+BB;
23400 A[NK]←AA-RE; A[K]←AA+RE;
23500 DC←R*CK+DC; CK←CK+DC;
23600 DS←R*SK+DS; SK←SK+DS;
23700 END;
23800 END "RTRAN";
23900
24000
30000 PROCEDURE RFOUR(REAL_ARRAY A,B;INTEGER M,INVERSE);
30100 BEGIN
30200 COMMENT COMPUTES THE FFT OF 2↑(M+1) REAL DATA POINTS;
30300 INTEGER N,J;
30400 REAL P;
30500 N←2↑M;
30600 IF INVERSE THEN
30700 BEGIN
30800 RTRAN(A,B,N,TRUE);
30900 FOR J←N-1 STEP -1 UNTIL 0 DO
31000 B[J]←-B[J];
31100 FFT(A,B,N,M,N);
31200 FOR J←N-1 STEP -1 UNTIL 0 DO
31300 BEGIN A[J]←0.5*A[J]; B[J]←-0.5*B[J] END;
31400 REORDER(A,B,N,M,N,TRUE);
31500 END
31600 ELSE
31700 BEGIN
31800 REORDER(A,B,N,M,N,TRUE);
31900 REVFFT(A,B,N,M,1); P←0.5/N;
32000 FOR J←N-1 STEP -1 UNTIL 0 DO
32100 BEGIN A[J]←P*A[J]; B[J]←P*B[J] END;
32200 RTRAN(A,B,N,FALSE);
32300 END;
32400 END "RFOUR";
32500
32600
33000 PROCEDURE CFOUR(REAL_ARRAY A,B;INTEGER M,INVERSE);
33100 BEGIN
33200 COMMENT COMPUTES THE FFT OF 2↑M COMPLEX DATA VALUES Xi IF INVERSE IS TRUE;
33300 INTEGER N,J;
33400 REAL P,Q;
33500 N←2↑M; P←Q←1.0/SQRT(N);
33600 IF INVERSE THEN
33700 BEGIN
33800 Q←-Q;
33900 FOR J←N-1 STEP -1 UNTIL 0 DO B[J]←-B[J];
34000 END;
34100 FFT(A,B,N,M,N); REORDER(A,B,N,M,N,FALSE);
34200 FOR J←N-1 STEP -1 UNTIL 0 DO
34300 BEGIN A[J]←A[J]*P; B[J]←B[J]*Q; END;
34400 END "CFOUR";
00100 PROCEDURE SETFOR(REAL_ARRAY A,B;INTEGER_ARRAY PIC;REFERENCE INTEGER N,LIN);
00200 BEGIN
00300 COMMENT THIS PROCEDURE SETS UP THE TWO ARRAY OF LENGTH N FOR THE FFT;
00400 INTEGER BPT,I,J,FILL1,FILL2,HOLD;
00410 REAL PI;
00415 PI←3.1415926536;
00420 BPT←POINT(BPS,LIN,-1);
00440 HOLD←ILDB(BPT);
00500 FILL1←(2*N-PIC[SIZEX])%2;
00600 FILL2←2*N-PIC[SIZEX]-FILL1;
00700 BPT← POINT(BPS,LIN,-1);
00800 FOR I←0 STEP 1 UNTIL FILL1-1 DO A[I]←HOLD*SIN((PI*I)/(2*FILL1));
00900 FOR I←I STEP 1 UNTIL N-1 DO A[I]←ILDB(BPT);
01000 FOR I←0 STEP 1 UNTIL N-FILL2-1 DO B[I]←ILDB(BPT);
01020 J←I; HOLD←B[I-1];
01100 FOR I←I STEP 1 UNTIL N-1 DO B[I]←HOLD*SIN((PI*(FILL2+J-I))/(2*FILL2));
01200 END "SETFOR";
01300
01305 PROCEDURE COMSET(INTEGER_ARRAY PIC;REFERENCE INTEGER N,LIN);
01318 BEGIN
01331 COMMENT THIS PROCEDURE SETS UP THE TWO ARRAYS OF LENGTH N FOR THE COMPLEX FFT;
01344 INTEGER BPT,I,J;
01345 REAL PI,HOLD;
01351 BPT←POINT(BPS,LIN,-1);
01354 HOLD←ILDB(BPT);
01383 BPT← POINT(BPS,LIN,-1);
01384 START_CODE
01385 LABEL M,M1,M2,LD1;
01386 DEFINE TMP="5",R="6",I="7",J="'13",K="'14";
01388 MOVN TMP, LFILL1;
01390 HRLZ J, TMP;
01392 M1: MOVE R, LSINE[0] (J);
01394 FMPR R, HOLD; COMMENT SETTING UP THE SINE FILL IN A;
01396 MOVEM R, A[0] (J);
01398 AOBJN J, M1;
01400 MOVN TMP, PPL;
01402 HRL J, TMP;
01404 LD1: ILDB R, BPT;
01406 FSC R, '233;
01408 MOVEM R, A[0] (J); COMMENT LOADING A WITH SAMPLES;
01410 AOBJN J, LD1;
01412 MOVN TMP, LFILL2;
01413 SUBI TMP, 1;
01414 HRL J, TMP;
01416 MOVE K, LFILL2;
01418 M2: MOVE TMP, LSINE[0] (K);
01420 FMPR TMP, R; COMMENT SINE FILL A AT END;
01422 MOVEM TMP, A[0] (J);
01424 SUBI K, 1;
01426 AOBJN J, M2;
01430 MOVN I, LN;
01431 SUBI I, 1;
01432 HRLZ J, I;
01435 MOVEI I, 0;
01440 M: MOVEM I, B[0] (J);
01445 AOBJN J, M;
01450 END;
01480 END "COMSET";
01490
01500 PROCEDURE REPACK(REAL_ARRAY A,B;INTEGER_ARRAY PIC;REFERENCE INTEGER N,LIN);
01600 BEGIN
01700 COMMENT THIS PROCEDURE PACKS THE DATA IN A AND B INTO BYTES OF LIN;
01800 INTEGER BPT,I,J,SKIP1,SKIP2,HOLD,LIM;
01900 SKIP1←(2*N-PIC[SIZEX])%2;
01905 SKIP2←2*N-PIC[SIZEX]-SKIP1;
01906 LIM←2↑BPS-1;
01908 BPT← POINT(BPS,LIN,-1);
01910 FOR I←SKIP1 STEP 1 UNTIL N-1 DO BEGIN HOLD←A[I]; IF HOLD<0 THEN IDPB(0,BPT) ELSE
01915 BEGIN IF HOLD>LIM THEN IDPB(LIM,BPT) ELSE IDPB(HOLD,BPT);END;END;
01920 FOR I←0 STEP 1 UNTIL N-SKIP2-1 DO BEGIN HOLD←B[I]; IF HOLD<0 THEN IDPB(0,BPT) ELSE
01925 BEGIN IF HOLD > LIM THEN IDPB(LIM,BPT); IDPB(HOLD,BPT); END;END;
01930 END "REPACK";
02000 PROCEDURE ARRDIS(REAL_ARRAY A; INTEGER N,XPOS,YPOS;STRING ID);
02100 BEGIN
02200 COMMENT DISPLAYS A HISTOGRAM OF THE FIRST N VALUES OF ARRAY A AT 0,POS;
02300 INTEGER I,J,SP;
02350 INTEGER LY,DY;
02400 REAL MAX;
02450 MAX←0;
02500 FOR I←0 STEP 1 UNTIL N DO
02600 IF ABS(A[I])>MAX THEN MAX←ABS(A[I]);
02800 MAX←MAX/250;
03000 SP←512%N; COMMENT HORIZONTAL SPACING;
03100 AIVECT(XPOS,YPOS); RVECT(511,0); RIVECT(-511,0); RVECT(0,250); RIVECT(0,-250);
03150 LY←A[0]/MAX+YPOS;
03200 AIVECT(XPOS,LY);
03300 FOR I←1 STEP 1 UNTIL N DO
03320 BEGIN
03340 DY←A[I]/MAX+YPOS-LY;
03360 LY←LY+DY;
03380 RVECT(SP,DY);
03400 END;
03455 AIVECT(XPOS,YPOS);
03460 FOR I←1 STEP 10*SP UNTIL 512 DO
03465 BEGIN
03470 RVECT(0,-10); COMMENT HORIZONTAL SCALE;
03475 RIVECT(10*SP,10);
03480 END;
03490 AIVECT(XPOS,YPOS-40);
03500 DPYSST(ID);
04000 END "ARRDIS";
05000 PROCEDURE DUBDIS(REAL_ARRAY A,B; INTEGER N,XPOS,YPOS;STRING ID);
05100 BEGIN
05200 COMMENT DISPLAYS A HISTOGRAM OF THE FIRST N VALUES OF ARRAY A AT 0,POS;
05300 INTEGER I,J,SP;
05400 INTEGER LY,DY;
05450 REAL MAX;
05475 MAX←0;
05800 FOR I←0 STEP 1 UNTIL N DO
05900 IF ABS(A[I])>MAX THEN MAX←ABS(A[I]);
05950 FOR I←0 STEP 1 UNTIL N DO
05975 IF ABS(B[I])>MAX THEN MAX←ABS(B[I]);
06000 MAX←MAX/250;
06200 SP←512%N; COMMENT HORIZONTAL SPACING;
06300 AIVECT(XPOS,YPOS); RVECT(1023,0); RIVECT(-1023,0); RVECT(0,250); RIVECT(0,-250);
06400 LY←A[0]/MAX+YPOS;
06500 AIVECT(XPOS,LY);
06600 FOR I←1 STEP 1 UNTIL N DO
06700 BEGIN
06800 DY←A[I]/MAX+YPOS-LY;
06900 LY←LY+DY;
07000 RVECT(SP,DY);
07100 END;
07110 FOR I←1 STEP 1 UNTIL N DO
07125 BEGIN
07140 DY←B[I]/MAX+YPOS-LY;
07155 LY←LY+DY;
07170 RVECT(SP,DY);
07185 END;
07190 AIVECT(XPOS,YPOS-40);
07195 DPYSST(ID);
07200 END "DUBDIS";
08000 PROCEDURE POWER(REAL_ARRAY A,B,C;INTEGER N);
08100 BEGIN
08200 COMMENT THIS COMPUTES THE POWER SPECTRUM OF THE SIN AND COS SERIES IN A,B;
08300 INTEGER I;
08400 FOR I←0 STEP 1 UNTIL N DO
08500 C[I]←SQRT(A[I]↑2 + B[I]↑2)+C[I];
08600 END "POWER";
08700
08800
08900
09000 PROCEDURE FPACK(REAL_ARRAY A,B;INTEGER_ARRAY PIC;REFERENCE INTEGER N,LIN);
09100 BEGIN
09200 COMMENT THIS PROCEDURE SCALES A AND B TO BPS AND PACKS IT STARTING IN LIN;
09300 REAL MAX,MIN;
09400 INTEGER I,BPT,HOLD;
09500 MAX←MIN←0;
09600 FOR I←0 STEP 1 UNTIL N DO
09700 BEGIN
09800 IF ABS(A[I])>MAX THEN MAX←ABS(A[I]);
09900 IF ABS(B[I])>MAX THEN MAX←ABS(B[I]);
10200 END;
10300 SCALE←MAX/(2↑(BPS-1)-1);
10400 BPT←POINT(BPS,LIN,-1);
10500 FOR I←0 STEP 1 UNTIL N DO BEGIN HOLD←A[I]/SCALE; IDPB(HOLD,BPT); END;
10600 FOR I←0 STEP 1 UNTIL N DO BEGIN HOLD←B[I]/SCALE; IDPB(HOLD,BPT); END;
10700 END "FPACK";
10720
11000 PROCEDURE UNPACK(REAL_ARRAY A,B;INTEGER_ARRAY PIC;REFERENCE INTEGER N,LIN);
11100 BEGIN
11200 COMMENT THIS PROCEDURE SETS UP THE TWO ARRAY OF LENGTH N FOR THE INVERSE FFT;
11300 INTEGER I,BPT,DI,LEFT;
11320 LEFT←36-(BPS); DI←2↑(36-(BPS));
11400 BPT←POINT(BPS,LIN,-1);
11500 FOR I←0 STEP 1 UNTIL N DO A[I]←((ILDB(BPT) LSH LEFT)%DI)*SCALE;
11600 FOR I←0 STEP 1 UNTIL N DO B[I]←((ILDB(BPT) LSH LEFT)%DI)*SCALE;
11700 END "UNPACK";
00100 PROCEDURE CFPACK(REAL_ARRAY A,B;INTEGER_ARRAY RPIC,IPIC;INTEGER L);
00200 BEGIN
00300 COMMENT THIS PACKS THE COMPLEX VECTOR IN A,B INTO AN ARRAY AT LINE L;
00400 INTEGER RBPT,IBPT,I,HOLD;
00450 REAL RSCALE,RMAX,ISCALE,IMAX;
00475 RMAX←IMAX←0;
00500 RBPT←RPIC[PTR]+(L-1)*RPIC[SIZEL];
00550 IBPT←IPIC[PTR]+(L-1)*IPIC[SIZEL];
00600 START_CODE
00605 LABEL M1,M2;
00610 DEFINE I="'13", J="'14";
00615 MOVN I, LN;
00618 SUBI I, 1;
00620 HRLZ J, I;
00630 MOVE I, A;
00635 HRRM I, M1;
00640 MOVE I, B;
00645 HRRM I, M2;
00650 M1: MOVM I, (J);
00655 CAMLE I, RMAX;
00660 MOVEM I, RMAX;
00665 M2: MOVM I, (J);
00670 CAMLE I, IMAX;
00675 MOVEM I, IMAX;
00680 AOBJN J, M1;
00685 END;
01100 RSCALE←RMAX/(2↑(RPIC[BIT]-1)-1);
01150 ISCALE←IMAX/(2↑(IPIC[BIT]-1)-1);
01300 START_CODE
01305 LABEL M1,M2;
01310 DEFINE I="'13", J="'14" , FIX="'247000000000";
01315 MOVN I, LN;
01318 SUBI I, 1;
01320 HRLZ J, I;
01330 MOVE I, A;
01335 HRRM I, M1;
01340 MOVE I, B;
01345 HRRM I, M2;
01350 M1: MOVE I, (J);
01355 FDVR I, RSCALE;
01360 FIX I, '233000;
01365 IDPB I, RBPT;
01370 M2: MOVE I, (J);
01375 FDVR I, ISCALE;
01380 FIX I, '233000;
01385 IDPB I, IBPT;
01410 AOBJN J, M1;
01415 END;
01620 RLSCL[L]←RSCALE; ILSCL[L]←ISCALE;
01700 END "CFPACK";
02000 PROCEDURE COLSET(INTEGER_ARRAY RPIC,IPIC;INTEGER RBYTE,IBYTE);
02100 BEGIN
02200 COMMENT PUTS THE Ith COL OF RPIC AND IPIC INTO A AND B AND FILLS TO 2↑M;
02300 INTEGER RBPT,IBPT,I,J,N,RSL,ISL;
02350 INTEGER RMSK,IMSK,RSIGN,ISIGN;
02400 REAL RHOLD,IHOLD;
02450 N←RPIC[SIZEY]-1;
02610 RBPT←RBYTE; IBPT←IBYTE;
02620 RSL←RPIC[SIZEL];ISL←IPIC[SIZEL];
02700 RMSK←2↑(RPIC[BIT]-1); RSIGN←2*RMSK-1;
02710 IMSK←2↑(IPIC[BIT]-1); ISIGN←2*IMSK-1;
02910 START_CODE
02915 LABEL LAB1,LAB2,LD;
02920 DEFINE TMP="5",R="6",I="7",J="'13",K="'14";
02930 MOVN TMP, CFILL1; COMMENT SET UP THE SINE FILL;
02940 HRLZ J , TMP;
02942 LDB R, RBPT;
02943 TDNE R, RMSK;
02944 ORCM R, RSIGN;
02945 FSC R, '233;
02946 FMPR R, RLSCL[1];
02947 MOVEM R, RHOLD;
02948 LDB I, IBPT;
02949 TDNE I, IMSK;
02950 ORCM I, ISIGN;
02951 FSC I, '233;
02952 FMPR I, ILSCL[1];
02953 MOVEM I, IHOLD;
02958 LAB1: MOVE R, CSINE[0] (J); COMMENT CONVERT THE BYTES TO FLT PNT;
02960 FMPR R, RHOLD;
02970 MOVEM I, A[0] (J);
02980 MOVE I, CSINE[0] (J);
02990 FMPR I, IHOLD;
03000 MOVEM I, B[0] (J);
03010 AOBJN J, LAB1;
03020 MOVN TMP, LINES;
03030 HRL J , TMP;
03035 MOVEI K, 0;
03040 LD: LDB R, RBPT;
03050 TDNE R, RMSK;
03060 ORCM R, RSIGN;
03070 FSC R, '233;
03080 FMPR R, RLSCL[1] (K);
03090 MOVEM R, A[0] (J);
03100 LDB I, IBPT;
03110 TDNE I, IMSK;
03120 ORCM I, ISIGN;
03130 FSC I, '233;
03140 FMPR I, ILSCL[1] (K);
03150 MOVEM I, B[0] (J);
03160 MOVE TMP, RSL; COMMENT UPDATE BYTE POINTERS;
03170 ADDM TMP, RBPT;
03180 MOVE TMP, ISL;
03190 ADDM TMP, IBPT;
03195 ADDI K, 1;
03200 AOBJN J, LD;
03210 MOVE K, CFILL2; COMMENT NOW THE SINE FILL AT THE END;
03220 MOVN TMP, CFILL2;
03230 HRL J , TMP;
03240 LAB2: MOVE TMP, CSINE[0] (K);
03250 FMPR TMP, R;
03260 MOVEM TMP, A[0] (J);
03270 MOVE TMP, CSINE[0] (K);
03280 FMPR TMP, I;
03290 MOVEM TMP, B[0] (J);
03300 SUBI K, 1;
03310 AOBJN J, LAB2;
03320 END;
04500 END "COLSET";
05000 PROCEDURE COLPAK(INTEGER_ARRAY RPIC,IPIC;INTEGER RBYTE,IBYTE,C);
05100 BEGIN
05200 COMMENT THIS PACK THE COMPLEX VECTOR IN A,B INTO AN ARRAY AT COLUMN C;
05300 INTEGER RBPT,IBPT,I,N,RSL,ISL,HOLD,LIM;
05350 REAL RSCALE,RMAX,ISCALE,IMAX;
05400 N←RPIC[SIZEY]-1;
05450 LIM←2↑RPIC[BIT]-1;
05475 RMAX←IMAX←0;
05500 RBPT←RBYTE; IBPT←IBYTE;
05600 RSL←RPIC[SIZEL];ISL←IPIC[SIZEL];
05700 START_CODE
05710 LABEL M1;
05720 DEFINE I="'13", J="'14";
05730 MOVN I, CN;
05735 SUBI I, 1;
05740 HRLZ J, I;
05800 M1: MOVM I, A[0] (J);
05810 CAMLE I, RMAX;
05820 MOVEM I, RMAX;
05830 MOVM I, B[0] (J);
05840 CAMLE I, IMAX;
05850 MOVEM I, IMAX;
05860 AOBJN J, M1;
05870 END;
05880 RSCALE←RMAX/(2↑(RPIC[BIT]-1)-1);
05890 ISCALE←IMAX/(2↑(IPIC[BIT]-1)-1);
05900 START_CODE
05910 LABEL M1;
05920 DEFINE I="'13", J="'14" , FIX="'247000000000";
05930 MOVN I, CN;
05935 SUBI I, 1;
05940 HRLZ J, I;
06000 M1: MOVE I, A[0] (J);
06010 FDVR I, RSCALE;
06020 FIX I, '233000;
06030 DPB I, RBPT;
06040 MOVE I, B[0] (J);
06050 FDVR I, ISCALE;
06060 FIX I, '233000;
06070 DPB I, IBPT;
06080 MOVE I, RSL;
06090 ADDM I, RBPT;
06100 MOVE I, ISL;
06110 ADDM I, IBPT;
06120 AOBJN J, M1;
06130 END;
06750 RCSCL[C]←RSCALE; ICSCL[C]←ISCALE;
06800 END "COLPAK";
06810
06829 PROCEDURE POW2D(INTEGER_ARRAY RPIC,IPIC);
06848 BEGIN
06867 COMMENT THIS CREATES A 2-D POWER SPECTRUM OF RPIC AND IPIC, STORED IN RPIC;
06886 INTEGER I,J,HOLD,BPT,RBPT,IBPT,RLEFT,ILEFT,RDI,IDI;
06887 REAL SCALE,MAX,TEMP;
06889 MAX←0;
06891 IF (TPICID←STRIN("POWER IMAGE="))≠NULL THEN PICID←TPICID;
06893 OUTCHN←GETCHAN;
06895 OPEN(OUTCHN,"DSK",'10,0,10,0,0,0);
06897 ENTER(OUTCHN,PICID,0);
06898 FOR I←1 STEP 1 UNTIL PICMAX DO PPIC[I]←RPIC[I]; PPIC[BIT]←8; PPIC[PTR]←0;
06899 PPIC[SIZEL]←(PPIC[SIZEX]-1)%(36%PPIC[BIT])+1;
06900 QTOHE(PPIC);
06901 ARRYOUT(OUTCHN,BCLIP,10); COMMENT OUTPUT THE HEADER;
06908 RLEFT←36-RPIC[BIT]; RDI←2↑(36-RPIC[BIT]);
06910 ILEFT←36-IPIC[BIT]; IDI←2↑(36-IPIC[BIT]);
06924 FOR I←1 STEP 1 UNTIL RPIC[SIZEY] DO
06943 BEGIN
06950 RBPT←RPIC[PTR]+(I-1)*RPIC[SIZEL];
06955 IBPT←IPIC[PTR]+(I-1)*IPIC[SIZEL];
06962 FOR J←1 STEP 1 UNTIL RPIC[SIZEX] DO
06981 BEGIN
06985 IF (TEMP←(((ILDB(RBPT) LSH RLEFT)%RDI)*RCSCL[J])↑2 + (((ILDB(IBPT) LSH ILEFT)%IDI)*ICSCL[J])↑2) > MAX THEN MAX←TEMP;
06990 END; END;
06995 SCALE←SQRT(MAX)/(2↑PPIC[BIT]-1);
06998 OUTSTR("SCALE="&CVF(SCALE));
07000 FOR I←1 STEP 1 UNTIL RPIC[SIZEY] DO
07005 BEGIN
07007 BPT←POINT(PPIC[BIT],AIBLK[1],-1);
07010 RBPT←RPIC[PTR]+(I-1)*RPIC[SIZEL];
07015 IBPT←IPIC[PTR]+(I-1)*IPIC[SIZEL];
07020 FOR J←1 STEP 1 UNTIL RPIC[SIZEX] DO
07025 BEGIN
07030 HOLD←SQRT((((ILDB(RBPT) LSH RLEFT)%RDI)*RCSCL[J])↑2 + (((ILDB(IBPT) LSH ILEFT)%IDI)*ICSCL[J])↑2)/SCALE;
07032 IDPB(HOLD,BPT);
07035 END;
07037 ARRYOUT(OUTCHN,AIBLK[1],PPIC[SIZEL]);
07040 END;
07043 CLOSE(OUTCHN);
07050 END "POW2D";
07060
07070
07080
07098 PROCEDURE OUTPIC(INTEGER_ARRAY PIC;STRING DEST);
07100 BEGIN
07200 COMMENT OUTPUTS AN IMAGE DEFINED BY PIC TO THE DSK;
07300 INTEGER CHN,ADR;
07400 QTOHE(PIC);
07500 OPEN(CHN←GETCHAN,"DSK",'10,0,11,0,0,0);
07600 ENTER(CHN,DEST,0);
07700 ARRYOUT(CHN,BCLIP,10); ⊃ Output the header parameters;
07800 ADR←PIC[PTR] LAND '777777;
07900 START_CODE
08000 DEFINE P="'17";
08100 PUSH P,CHN;PUSH P,ADR;PUSH P,SIZE;PUSHJ P,ARRYOUT;⊃ output the picture;
08200 END;
08400 RELEASE(CHN);
08500 END "OUTPIC";
08510
08520
08600 PROCEDURE COLUPK(REAL_ARRAY A,B;INTEGER_ARRAY RPIC,IPIC;INTEGER RBYTE,IBYTE,C);
08700 BEGIN
08800 COMMENT CONVERTS PACKED COLUMNS INTO REAL A,B, FOR INVERSE FFT;
08900 INTEGER RBPT,IBPT,I,RSL,ISL,HOLD;
08950 INTEGER RMSK,IMSK,RSIGN,ISIGN;
09000 REAL RSCALE,ISCALE;
09050 RSCALE←RCSCL[C]; ISCALE←ICSCL[C];
09100 RBPT←RBYTE; IBPT←IBYTE;
09200 RSL←RPIC[SIZEL];ISL←IPIC[SIZEL];
09300 RMSK←2↑(RPIC[BIT]-1); RSIGN←2*RMSK-1;
09400 IMSK←2↑(IPIC[BIT]-1); ISIGN←2*IMSK-1;
09500 START_CODE
09510 LABEL M1,M2,LD;
09520 DEFINE I="'13", J="'14";
09530 MOVN I, CN;
09535 SUBI I, 1;
09540 HRLZ J,I;
09550 MOVE I, A;
09560 HRRM I, M1;
09570 MOVE I, B;
09580 HRRM I,M2;
09590 LD: LDB I, RBPT;
09600 TDNE I, RMSK;
09610 ORCM I, RSIGN;
09620 FSC I, '233;
09630 FMPR I, RSCALE;
09640 M1: MOVEM I, (J);
09650 LDB I, IBPT;
09660 TDNE I, IMSK;
09670 ORCM I, ISIGN;
09680 FSC I, '233;
09690 FMPR I, ISCALE;
09700 M2: MOVEM I, (J);
09702 MOVE I, RSL;
09704 ADDM I, RBPT;
09706 MOVE I, ISL;
09708 ADDM I, IBPT;
09710 AOBJN J, LD;
10200 END;
10300 END "COLUPK";
10400
10500
11000 PROCEDURE COLRPK(REAL_ARRAY A,B;INTEGER_ARRAY RPIC,IPIC;INTEGER RBYTE,IBYTE,C);
11100 BEGIN
11200 COMMENT THIS PACK THE COMPLEX VECTOR IN A,B INTO AN ARRAY AT COLUMN C AND REMOVES THE 2↑M FILL;
11300 INTEGER RBPT,IBPT,I,N,RSL,ISL,HOLD,LIM,SKIP;
11400 REAL RSCALE,RMAX,ISCALE,IMAX;
11500 N←RPIC[SIZEY]-1;
11600 LIM←2↑RPIC[BIT]-1;
11700 RMAX←IMAX←0;
11800 RBPT←RBYTE; IBPT←IBYTE;
11900 RSL←RPIC[SIZEL];ISL←IPIC[SIZEL];
11950 SKIP←(RPIC[SIZEY]-LINES-1)%2;
12100 START_CODE
12110 LABEL M1,M2;
12120 DEFINE I="'13", J="'14";
12160 MOVN I, LINES;
12170 HRLZ J, I;
12180 HRR J, CFILL1;
12190 MOVE I, A;
12200 HRRM I, M1;
12210 MOVE I, B;
12220 HRRM I, M2;
12230 M1: MOVM I, (J);
12240 CAMLE I, RMAX;
12250 MOVEM I, RMAX;
12260 M2: MOVM I, (J);
12270 CAMLE I, IMAX;
12280 MOVEM I, IMAX;
12290 AOBJN J, M1;
12300 END;
12600 RSCALE←RMAX/(2↑(RPIC[BIT]-1)-1);
12700 ISCALE←IMAX/(2↑(IPIC[BIT]-1)-1);
12800 START_CODE
12810 LABEL M1,M2;
12820 DEFINE I="'13", J="'14" , FIX="'247000000000";
12830 MOVN I, LINES;
12840 HRLZ J, I;
12850 HRR J, CFILL1;
12860 MOVE I, A;
12870 HRRM I, M1;
12880 MOVE I, B;
12890 HRRM I, M2;
12900 M1: MOVE I, (J);
12910 FDVR I, RSCALE;
12920 FIX I, '233000;
12930 DPB I, RBPT;
12940 M2: MOVE I, (J);
12950 FDVR I, ISCALE;
12960 FIX I, '233000;
12970 DPB I, IBPT;
12980 MOVE I, RSL;
12990 ADDM I, RBPT;
13000 MOVE I, ISL;
13010 ADDM I, IBPT;
13020 AOBJN J, M1;
13030 END;
13200 RCSCL[C]←RSCALE; ICSCL[C]←ISCALE;
13300 END "COLRPK";
13400
13500
14000 PROCEDURE LINUPK(INTEGER_ARRAY RPIC,IPIC;INTEGER L);
14100 BEGIN
14200 COMMENT THIS UNPACKS THE LINE L AND PUTS IT IN A AND B FOR THE COMPLEX INVERSE FFT;
14300 INTEGER RBPT,IBPT,I,HOLD;
14350 INTEGER RMSK,IMSK,RSIGN,ISIGN;
14400 RBPT←RPIC[PTR]+(L-1)*RPIC[SIZEL];
14500 IBPT←IPIC[PTR]+(L-1)*IPIC[SIZEL];
14550 RMSK←2↑(RPIC[BIT]-1); RSIGN←2*RMSK-1;
14560 IMSK←2↑(IPIC[BIT]-1); ISIGN←2*IMSK-1;
14570 START_CODE
14580 LABEL LD;
14590 DEFINE I="'13", J="'14";
14600 MOVN I, LN;
14610 SUBI I, 1;
14620 HRLZ J,I;
14670 LD: ILDB I, RBPT;
14680 TDNE I, RMSK;
14690 ORCM I, RSIGN;
14700 FSC I, '233;
14710 FMPR I, RCSCL[1] (J);
14720 MOVEM I, A[0] (J);
14730 ILDB I, IBPT;
14740 TDNE I, IMSK;
14750 ORCM I, ISIGN;
14760 FSC I, '233;
14770 FMPR I, ICSCL[1] (J);
14780 MOVEM I, B[0] (J);
14830 AOBJN J, LD;
14840 END;
15100 END "LINUPK";
15200
15300
16000 PROCEDURE OUTPCK(INTEGER_ARRAY RPIC,IPIC;INTEGER L);
16100 BEGIN
16200 COMMENT THIS PACKS THE VALUES IN A AND B INTO AIBLK FOR OUTPUT TO THE DISK;
16300 INTEGER BPT,I,HOLD,LIM,SKIP;
16500 BPT←POINT(PIC[BIT],AIBLK[1],-1);
16600 LIM←2↑PIC[BIT]-1;
16710 START_CODE
16720 LABEL M,L1,L2,REPT;
16730 DEFINE TMP="5",L="6",Z="7",J="'13",FIX="'247000000000";
16740 MOVEI Z, 0;
16750 MOVE L, LIM;
16760 MOVN TMP, PPL;
16770 HRLZ J, TMP;
16780 HRR J, LFILL1;
16790 M: MOVE TMP, A[0] (J);
16800 FIX TMP, '233000;
16810 CAMG TMP, L;
16820 JRST L1;
16830 IDPB L, BPT;
16840 JRST REPT;
16850 L1: CAIL TMP, 0;
16860 JRST L2;
16870 IDPB Z, BPT;
16880 JRST REPT;
16890 L2: IDPB TMP, BPT;
16900 REPT: AOBJN J, M;
16910 END;
17400 END "OUTPCK";
17500
17600
00100 AIFORM←1;
00150 PI←3.14159265;
00200 START: ;
00300 IF (TPICID←STRIN("IMAGE="))≠NULL THEN PICID←TPICID;
00350 CLOSE(AIFORM);
00400 OPEN(AIFORM,"DSK",'10,10,0,0,0,0);
00500 LOOKUP(AIFORM,PICID&".DAT",0);
00600 ARRYIN(AIFORM,BCLIP,10); COMMENT INPUT THE HEADER;
00700 HETOQ(PIC);
00800 PPL←PIC[SIZEX]; LINES←PIC[SIZEY];
00850 BPS←PIC[BIT];
00900 LM ←ALOG10(PPL)%ALOG10(2)+1; LN←2↑LM;
00950 CM ←ALOG10(LINES)%ALOG10(2)+1; CN←2↑CM;
00955 LFILL1←(LN-PIC[SIZEX])%2;
00960 LFILL2←LN-PIC[SIZEX]-LFILL1;
00965 CFILL1←(CN-LINES)%2;
00970 CFILL2←CN-LINES-CFILL1;
00975 FOR I←0 STEP 1 UNTIL LFILL2 DO LSINE[I]←SIN((PI*I)/(2*LFILL2));
00980 FOR I←0 STEP 1 UNTIL CFILL2 DO CSINE[I]←SIN((PI*I)/(2*CFILL2));
01000 FOR I←0 STEP 1 UNTIL PICMAX DO RPIC[I]←PIC[I];
01100 RPIC[SIZEX]←LN+1; RPIC[SIZEY]←CN+1;
01200 RPIC[BIT]←9;
01300 RPIC[SIZEL]←(RPIC[SIZEX]-1)%(36%RPIC[BIT])+1;
01325 RPIC[PTR]←0;
01350 FOR I←1 STEP 1 UNTIL PICMAX DO IPIC[I]←RPIC[I];
01400 PICMAK(RPIC);
01450 PICMAK(IPIC);
01500 FOR I←1 STEP 1 UNTIL PIC[SIZEY] DO
01600 BEGIN
01700 ARRYIN(AIFORM,AIBLK[1],PIC[SIZEL]);
01800 COMSET(PIC,LN,AIBLK[1]);
01900 CFOUR(A,B,LM,1);
02000 CFPACK(A,B,RPIC,IPIC,I);
02100 END;
02150 OUTSTR("2150");
02175 RBYTE←RPIC[PTR]; IBYTE←IPIC[PTR];
02200 FOR I←1 STEP 1 UNTIL RPIC[SIZEX] DO
02300 BEGIN
02350 HOLD←ILDB(RBYTE); HOLD←ILDB(IBYTE);
02400 COLSET(RPIC,IPIC,RBYTE,IBYTE);
02500 CFOUR(A,B,CM,1);
02600 COLPAK(RPIC,IPIC,RBYTE,IBYTE,I);
02700 END;
02750 IF (TPICID←STRIN("REAL IMAGE="))≠NULL THEN
02800 OUTPIC(RPIC,TPICID);
02850 IF (TPICID←STRIN("IMAG IMAGE="))≠NULL THEN
02900 OUTPIC(IPIC,TPICID);
02925 IF STRIN("POWER SPECTRUM?(Y or N)")="Y" THEN
03000 POW2D(RPIC,IPIC);
03050 RBYTE←RPIC[PTR]; IBYTE←IPIC[PTR];
03100 FOR I←1 STEP 1 UNTIL RPIC[SIZEX] DO
03200 BEGIN
03250 HOLD←ILDB(RBYTE); HOLD←ILDB(IBYTE);
03300 COLUPK(A,B,RPIC,IPIC,RBYTE,IBYTE,I);
03400 CFOUR(A,B,CM,0);
03500 COLRPK(A,B,RPIC,IPIC,RBYTE,IBYTE,I);
03600 END;
03605 IF (TPICID←STRIN("NEW IMAGE="))≠NULL THEN PICID←TPICID;
03624 OUTCHN←GETCHAN;
03643 OPEN(OUTCHN,"DSK",'10,0,10,0,0,0);
03662 ENTER(OUTCHN,PICID,0);
03664 PIC[BIT]←6;
03666 PIC[SIZEL]←(PIC[SIZEX]-1)%(36%PIC[BIT])+1;
03670 QTOHE(PIC);
03681 ARRYOUT(OUTCHN,BCLIP,10); COMMENT OUTPUT THE HEADER;
03700 FOR I←1 STEP 1 UNTIL PIC[SIZEY] DO
03800 BEGIN
03900 LINUPK(RPIC,IPIC,I);
04000 CFOUR(A,B,LM,0);
04100 OUTPCK(RPIC,IPIC,I);
04150 ARRYOUT(OUTCHN,AIBLK[1],PIC[SIZEL]);
04200 END;
04300 CLOSE(OUTCHN);
05000 END "TWODIM";